home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / pascal / MAIL.SWG / 0008_Re: QWK & Turbo Pascal 7.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1996-02-21  |  5.5 KB  |  259 lines
  1. {P
  2.  MM> QWK:
  3.  MM> Can anybody write for me or send me a unit that reads QWK packets???
  4.  
  5. I've wrote my one:
  6. NOTE: Here some bugs can be found.Report me as soon as you check that.
  7.  
  8. ---8<--- Begin QWKUSE.PAS ---8<--- }
  9.  
  10. Unit QWKUse;
  11.  
  12. Interface
  13.  
  14. USES DOS,CRT;
  15.  
  16. Type QWKHead=Record
  17.      NOM :ARRAY [0..6] Of Char;
  18.      Date:ARRAY [7..$e] Of Char;
  19.      Time:ARRAY [$f..$13] Of Char;
  20.      to_:ARRAY [$14..$2c] Of Char;
  21.      From:ARRAY [$2d..$45] Of Char;
  22.      Subj:ARRAY [$46..$6a] Of Char;
  23.      NOR :ARRAY [$6b..$72] Of Char;
  24.      NOMB:ARRAY [$73..$78] Of Char;
  25.      Res :ARRAY [$79..$7e] Of Char;
  26.      End;
  27.      MessageBlock=Array[1..128] Of CHAR;
  28.  
  29. CONST CrLf=#13#10;
  30.  
  31. Function GetMessageLength(msg:QWKHead):BYte;
  32. Procedure GetMessageTime(msg:QWKHead;Var Hour,Minute:Byte);
  33. Procedure GetMessageDate(msg:QWKHead;Var DD,MM,YY:Word);
  34. Function MessageNumber(msg:QWKHead):Word;
  35. Function  NumberOfReplay(msg:QWKHead):WORd;
  36. Function  Replay(msg:QWKHead):Boolean;
  37. Procedure NormalCrLf(Var s:String);
  38. Procedure DelChr(c:Char;S:String);
  39.  
  40. Implementation
  41.  
  42. Procedure DelChr;
  43. Var a:Byte;
  44. Begin
  45. For a:=1 To Length(s) Do If s[a]=c Then Begin Delete(s,a,1);Dec(a);End;
  46. End;
  47.  
  48. Function GetMessageLength;
  49. Var s:String;
  50.     c:Integer;
  51.     len:Byte;
  52. Begin
  53. s:='';
  54. s:=s+msg.nomb;
  55. DelChr(' ',s);
  56. Val(s,len,c);
  57. Dec(Len);
  58. GetMessageLength:=len;
  59. End;
  60.  
  61. Procedure GetMessageTime(msg:QWKHead;Var Hour,Minute:Byte);
  62. Var s,s1:String;
  63.     c:INteger;
  64. Begin
  65. s1:='';s1:=s1+msg.time;
  66. s:=Copy(s1,1,2);
  67. Delete(s1,1,3);
  68. Val(s,hour,c);
  69. Val(s1,Minute,c);
  70. End;
  71.  
  72. Procedure GetMessageDate(msg:QWKHead;Var DD,MM,YY:Word);
  73. VAR s,s1:String;
  74.     c:INteger;
  75. Begin
  76. s1:='';s1:=s1+msg.date;
  77. s:=Copy(s1,1,2);
  78. Delete(s1,1,3);
  79. Val(s,mm,c);
  80. s:=Copy(s1,1,2);
  81. Delete(s1,1,3);
  82. Val(s,dd,c);
  83. Val(s1,yy,c);
  84. End;
  85.  
  86. Function  MessageNumber(msg:QWKHead):Word;
  87. Var s:String;
  88.     w:Word;
  89.     c:Integer;
  90. Begin
  91. s:=msg.nom;
  92. DelChr(' ',s);
  93. Val(s,w,c);
  94. MessageNumber:=w;
  95. End;
  96.  
  97. Function  NumberOfReplay(msg:QWKHead):WORd;
  98. Var s:String;
  99.     w:Word;
  100.     c:Integer;
  101. Begin
  102. s:=msg.nor;
  103. DelChr(' ',s);
  104. Val(s,w,c);
  105. NumberOfReplay:=w;
  106. End;
  107.  
  108. Function  Replay(msg:QWKHead):Boolean;
  109. Begin
  110. Replay:=NumberOfReplay(msg)<>0;
  111. End;
  112.  
  113. Procedure NormalCrLf(Var s:String);
  114. Var b,a:Byte;
  115. BEgin
  116. b:=Pos('',s);
  117. While b<>0 Do Begin Delete(s,b,1);Insert(crlf,s,b);b:=Pos('',s);End;
  118. End;
  119.  
  120. End. ---8<---  End QWKUSE.PAS  ---8<---
  121.  
  122. And here is example of usage:
  123.  
  124. ---8<--- Begin QWKPMG.PAS ---8<---
  125. Program QWK_PMG;
  126. Uses CRT,Objects,PMG_Str1,QWKuse;
  127.  
  128. Const box:Array [1..5] Of String=(
  129.       'From:',
  130.       'To  :',
  131.       'Subj:',
  132.       'Date:',
  133.       'Time:');
  134.  
  135. VAR Mes:Array [1..700] OF PString;
  136.     MsgPtr:Array [1..100,1..2] Of LongINT;
  137.     f2,f1:File;
  138.     current,Total:Word;
  139.     Header:QWKHEAD;
  140.     a:Integer;
  141.     c:Char;
  142.  
  143. Function FillStr(c:Char;a:Byte);
  144. Var S:String;
  145.     b:Byte;
  146. Begin
  147. s:='';
  148. For b:=1 To a s:=s+c;
  149. FillStr:=s;
  150. End;
  151.  
  152. Procedure Draw;
  153. Var fields:Array [1..5] Of String;
  154.     a:Byte;
  155. Begin
  156. Fields[1]:=''+Header.from;
  157. Fields[2]:=''+Header.To_;
  158. Fields[3]:=''+Header.Subj;
  159. Fields[4]:=''+Header.Date;
  160. Fields[5]:=''+Header.Time;
  161. TextColor(Cyan);
  162. For a:=1 To 5 Do WriteLn(box[a]);
  163. TextColor(Red);GotoXY(40,1);Write('Message ');
  164. TextColor(White);Write(Current);TextColor(red);
  165. Write(' of ');TextColor(White);Write(TOtal);
  166. TextBackGround(White);TextColor(Black);GotoXy(1,25);
  167. Write('"+" - next message  "-" - previouse message.',FillStr(' ',35));
  168. TextBackGround(Black);
  169. TextColor(LightGreen);
  170. For a:=1 To 5 Do
  171.     Begin
  172.     GotoXY(6,a);Write(fields[a]);
  173.     End;
  174. TextColor(White);WriteLn(Crlf,FillSTR('─',79),CrLf);
  175. End;
  176.  
  177. Procedure ReadMsg(n:LongInt);
  178. Var b,a:Byte;
  179.     CurMsgPtr:LongInt;
  180.     MsgBuf:MESsageBlock;
  181.     s:String;
  182. Begin
  183. Current:=n;
  184. Seek(f1,MSgPtr[n,2]);
  185. BlockRead(f1,Header,SizeOf(Header));
  186. ClrScr;
  187. Draw;
  188. b:=0;
  189. FOR a:=1 To GetMessageLength(Header) Do
  190.     BEGin
  191.     BlockRead(f1,MsgBuf,128);
  192.     s:='';s:=s+MsgBuf;
  193.     NormalCrLf(s);
  194.     While (Pos(CrLf,s)<>0) Or (s<>'') Do
  195.           BEGin
  196.                Inc(b);
  197.                DisposeStr(MES[b]);
  198.                While Pos(CrLf,s)=1 Do Delete(s,1,2);
  199.                If Length(s)=0 Then s:=' ';
  200.                If Pos(CrLf,s)<>0 Then Mes[b]:=NewStr( Copy(s,1,Pos(CrLf,s)-1)
  201. )               Else Mes[b]:=NewStr(s);
  202.                If pos('>',Mes[b]^)<>0 Then TextColor(LightGray) Else
  203. TextColor(Cyan);               IF Pos(CrLf,s)<>0 Then WriteLn(Mes[b]^) Else
  204. Write(Mes[b]^) ;               If WhereY>22 Then
  205.                   Begin
  206.                        GotoXY(1,WhereY+1);
  207.                        Write('Press any key to continue ...');
  208.                        ReadKEY;
  209.                        ClrScr;
  210.                        Draw;
  211.                   End;
  212.                If Pos(CrLf,s)<>0 Then Delete(s,1,Pos(CrLf,s)+1) Else s:='';
  213.  
  214.           End;
  215.  
  216.     End;
  217. End;
  218.  
  219. Procedure InitPStrings;
  220. Var a:Word;
  221.     s:String;
  222. Begin
  223. s:=FillSTR(' ',128);
  224. For a:=1 To 700 DO Mes[a]:=NewStr(s);
  225. End;
  226.  
  227. Procedure InitMsgBase;
  228. Var a:word;
  229. Begin
  230. Seek(f1,$81);
  231. a:=1;
  232. While Not Eof(f1) Do
  233.       Begin
  234.            MsgPtr[a,2]:=FilePos(f1);
  235.            BlockRead(f1,Header,SizeOf(Header));
  236.            MsgPTR[a,1]:=MessageNumber(Header);
  237.            Seek(f1,Filepos(f1)+128*GetMessageLength(Header)+1);
  238.            Inc(a);
  239.       End;
  240. Total:=a-1;
  241. END;
  242.  
  243. Begin
  244. Assign(f1,'messages.dat');
  245. Reset(f1,1);
  246. InitMsgBase;
  247. a:=1;
  248. REpeat
  249. ReadMsg(a);
  250. c:=ReadKey;
  251. If c='+' Then Inc(A);
  252. If c='-' Then Dec(A);
  253. If a<1 Then a:=Total;
  254.  
  255. if a>Total Then a:=1;
  256.  
  257. UNTIL c=#27;
  258. End. ---8<---  End QWKPMG.PAS  ---8<---
  259.